home *** CD-ROM | disk | FTP | other *** search
/ Power Programmierung / Power-Programmierung (Tewi)(1994).iso / acad / autolisp / sfill / sfill.lsp
Lisp/Scheme  |  1988-07-14  |  5KB  |  173 lines
  1. ; SFILL.LSP   1.0 July 14 1988
  2. ; By Jamie Clay
  3. ; [76703,4204]
  4. ;
  5. ; SFILL will construct an even division of SOLIDs between any 2 Arcs, 
  6. ; Lines or Polylines on any elevation plane.
  7. ;
  8. ; This routine was once RULESURF.lsp and much of the code was designed
  9. ; to collect and use 3dpoints for 3dfaces. It works well with the SOLID
  10. ; entity and I think you will find it very useful. Please feel free
  11. ; to modify and improve this code.
  12. ;
  13. ; Note: the entities must "read" in the same direction, else you will
  14. ; get a major bow tie effect.
  15.  
  16. (vmon)
  17. (setq res "10")
  18.  
  19. ; SPATHA Set up first path's point set
  20. (defun spatha (/ path1) 
  21.   (while (= entcheck nil) 
  22.     (setq patha (entsel "\nSelect first surface path: ")) 
  23.     (setq getit (cadr patha)) 
  24.     (setq patha (car patha)) 
  25.     (setq path1 (entget patha)) 
  26.     (if (assoc 38 path1) 
  27.       (setq elev1 (list (cdr (assoc 38 path1)))) 
  28.       (setq elev1 '(0)) 
  29.     ) 
  30.     (setq entcheck (cdr (assoc 0 path1))) 
  31.     (if (/= entcheck "POLYLINE") 
  32.       (if (or (= entcheck "ARC") (= entcheck "LINE")) 
  33.         (progn 
  34.           (command "PEDIT" patha "Y" "") 
  35.           (setq patha (ssget getit)) 
  36.           (setq patha (ssname patha 0)) 
  37.         ) 
  38.         (progn 
  39.           (Prompt "\nPlease use Arcs, Lines or Polylines!") 
  40.           (setq entcheck nil) 
  41.         ) 
  42.       ) 
  43.     ) 
  44.   ) 
  45.   (setq entcheck nil) 
  46.   (setq pathlist path1) 
  47.   (setq pathent patha) 
  48.   (pathout) 
  49.   (setq patha pnts) 
  50. ) 
  51.  
  52. ; SPATHB set up second path's point set
  53. (defun spathb (/ path2) 
  54.   (while (= entcheck nil) 
  55.     (setq pathb (entsel "\nSelect second surface path: ")) 
  56.     (setq getit (cadr pathb)) 
  57.     (setq pathb (car pathb)) 
  58.     (setq path2 (entget pathb)) 
  59.     (if (assoc 38 path2) 
  60.       (setq elev2 (list (cdr (assoc 38 path2)))) 
  61.       (setq elev2 '(0)) 
  62.     ) 
  63.     (setq entcheck (cdr (assoc 0 path2))) 
  64.     (if (/= entcheck "POLYLINE") 
  65.       (if (or (= entcheck "ARC") (= entcheck "LINE")) 
  66.         (progn 
  67.           (command "PEDIT" pathb "Y" "") 
  68.           (setq pathb (ssget getit)) 
  69.           (setq pathb (ssname pathb 0)) 
  70.         ) 
  71.         (progn 
  72.           (Prompt "\nPlease use Arcs, Lines or Polylines!") 
  73.           (setq entcheck nil) 
  74.         ) 
  75.       ) 
  76.     ) 
  77.   ) 
  78.   (setq entcheck nil) 
  79.   (setq pathlist path2) 
  80.   (setq pathent pathb) 
  81.   (pathout) 
  82.   (setq pathb pnts) 
  83. ) 
  84.  
  85.  
  86. ; PATHOUT - Divide and collect points
  87. (defun pathout (/ 1stpt) 
  88.   (while (/= stop "SEQEND") 
  89.     (progn 
  90.       (setq lastpl pathlist) 
  91.       (if (/= stop "SEQEND") 
  92.         (progn 
  93.           (setq pathlist (entget (setq pathent (entnext pathent)))) 
  94.           (if (= 1stpt nil) 
  95.             (setq 1stpt (cdr (assoc 10 pathlist))) 
  96.           ) 
  97.         ) 
  98.       ) 
  99.     ) 
  100.     (setq stop (cdr (assoc 0 pathlist))) 
  101.   ) 
  102.   (setq pnts 1stpt) 
  103.   (setq lastpt (cdr (assoc 10 lastpl))) 
  104.   (command "layer" "M" "$nodes" "") 
  105.   (command "divide" getit res) 
  106.   (setq points (ssget "x" '((8 . "$NODES")(0 . "POINT")))) 
  107.   (setq index (1- (sslength points))) 
  108.   (while (/= index -1) 
  109.     (progn 
  110.       (setq XY (ssname points index)) 
  111.       (setq XY (cdr (assoc 10 (entget XY)))) 
  112.       (setq pnts (append pnts XY)) 
  113.       (setq index (1- index)) 
  114.     ) 
  115.   ) 
  116.   (setq pnts (append pnts lastpt)) 
  117.   (command "undo" "1") 
  118.   (setq stop '()) 
  119. ) 
  120.  
  121. ; 3DPOINTS - build 3dpoints for surfaces 
  122. (defun 3dpoints () 
  123.   (if (= firstpass nil) 
  124.     (progn 
  125.       (setq pt1 (list (nth next1 patha))) 
  126.       (setq next1 (1+ next1)) 
  127.       (setq pt1 (append pt1 (list (nth next1 patha)))) 
  128.       (setq pt1 (append pt1 elev1)) 
  129.       (setq pt2 (list (nth next2 pathb))) 
  130.       (setq next2 (1+ next2)) 
  131.       (setq pt2 (append pt2 (list (nth next2 pathb)))) 
  132.       (setq pt2 (append pt2 elev2)) 
  133.       (setq firstpass 1) 
  134.     ) 
  135.     (progn 
  136.       (setq pt1 pt3) 
  137.       (setq pt2 pt4) 
  138.     ) 
  139.   ) 
  140.   (setq next1 (1+ next1)) 
  141.   (setq pt3 (list (nth next1 patha))) 
  142.   (setq next1 (1+ next1)) 
  143.   (setq pt3 (append pt3 (list (nth next1 patha)))) 
  144.   (setq pt3 (append pt3 elev1)) 
  145.   (setq next2 (1+ next2)) 
  146.   (setq pt4 (list (nth next2 pathb))) 
  147.   (setq next2 (1+ next2)) 
  148.   (setq pt4 (append pt4 (list (nth next2 pathb)))) 
  149.   (setq pt4 (append pt4 elev2)) 
  150. ) 
  151.  
  152. ;SFILL - The big cheese
  153. (defun c:SFILL (/ patha pathb elev1 elev2 next1 next2 firstpass) 
  154.   (setq res# (getstring (strcat "Resolution <"res">: ")))
  155.   (if (/= res# "")
  156.     (setq res res#)
  157.   )
  158.   (setvar "cmdecho" 0)
  159.   (spatha) 
  160.   (spathb) 
  161.   (setq next1 (setq next2 0)) 
  162.   (while (nth next2 pathb) 
  163.     (progn 
  164.       (3dpoints) 
  165.       (if (nth next2 pathb) 
  166.         (command "solid" pt1 pt2 pt3 pt4 "") 
  167.       ) 
  168.     ) 
  169.   ) 
  170.   (setq firstpass 0)
  171.   (setvar "cmdecho" 1) 
  172. ) 
  173.